home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / NEXT.pm < prev    next >
Text File  |  2009-10-01  |  16KB  |  538 lines
  1. package NEXT;
  2. $VERSION = '0.60_01';
  3. use Carp;
  4. use strict;
  5.  
  6. sub NEXT::ELSEWHERE::ancestors
  7. {
  8.     my @inlist = shift;
  9.     my @outlist = ();
  10.     while (my $next = shift @inlist) {
  11.         push @outlist, $next;
  12.         no strict 'refs';
  13.         unshift @inlist, @{"$outlist[-1]::ISA"};
  14.     }
  15.     return @outlist;
  16. }
  17.  
  18. sub NEXT::ELSEWHERE::ordered_ancestors
  19. {
  20.     my @inlist = shift;
  21.     my @outlist = ();
  22.     while (my $next = shift @inlist) {
  23.         push @outlist, $next;
  24.         no strict 'refs';
  25.         push @inlist, @{"$outlist[-1]::ISA"};
  26.     }
  27.     return sort { $a->isa($b) ? -1
  28.                 : $b->isa($a) ? +1
  29.                 :                0 } @outlist;
  30. }
  31.  
  32. sub AUTOLOAD
  33. {
  34.     my ($self) = @_;
  35.     my $depth = 1;
  36.     until ((caller($depth))[3] !~ /^\(eval\)$/) { $depth++ }
  37.     my $caller = (caller($depth))[3];
  38.     my $wanted = $NEXT::AUTOLOAD || 'NEXT::AUTOLOAD';
  39.     undef $NEXT::AUTOLOAD;
  40.     my ($caller_class, $caller_method) = $caller =~ m{(.*)::(.*)}g;
  41.     my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
  42.     croak "Can't call $wanted from $caller"
  43.         unless $caller_method eq $wanted_method;
  44.  
  45.     local ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN) =
  46.           ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN);
  47.  
  48.  
  49.     unless ($NEXT::NEXT{$self,$wanted_method}) {
  50.         my @forebears =
  51.             NEXT::ELSEWHERE::ancestors ref $self || $self,
  52.                            $wanted_class;
  53.         while (@forebears) {
  54.             last if shift @forebears eq $caller_class
  55.         }
  56.         no strict 'refs';
  57.         @{$NEXT::NEXT{$self,$wanted_method}} = 
  58.             map { *{"${_}::$caller_method"}{CODE}||() } @forebears
  59.                 unless $wanted_method eq 'AUTOLOAD';
  60.         @{$NEXT::NEXT{$self,$wanted_method}} = 
  61.             map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
  62.                 unless @{$NEXT::NEXT{$self,$wanted_method}||[]};
  63.         $NEXT::SEEN->{$self,*{$caller}{CODE}}++;
  64.     }
  65.     my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
  66.     while ($wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/
  67.            && defined $call_method
  68.            && $NEXT::SEEN->{$self,$call_method}++) {
  69.         $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
  70.     }
  71.     unless (defined $call_method) {
  72.         return unless $wanted_class =~ /^NEXT:.*:ACTUAL/;
  73.         (local $Carp::CarpLevel)++;
  74.         croak qq(Can't locate object method "$wanted_method" ),
  75.               qq(via package "$caller_class");
  76.     };
  77.     return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
  78.     no strict 'refs';
  79.     ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*:://
  80.         if $wanted_method eq 'AUTOLOAD';
  81.     $$call_method = $caller_class."::NEXT::".$wanted_method;
  82.     return $call_method->(@_);
  83. }
  84.  
  85. no strict 'vars';
  86. package NEXT::UNSEEN;        @ISA = 'NEXT';
  87. package NEXT::DISTINCT;        @ISA = 'NEXT';
  88. package NEXT::ACTUAL;        @ISA = 'NEXT';
  89. package NEXT::ACTUAL::UNSEEN;    @ISA = 'NEXT';
  90. package NEXT::ACTUAL::DISTINCT;    @ISA = 'NEXT';
  91. package NEXT::UNSEEN::ACTUAL;    @ISA = 'NEXT';
  92. package NEXT::DISTINCT::ACTUAL;    @ISA = 'NEXT';
  93.  
  94. package EVERY::LAST;        @ISA = 'EVERY';
  95. package EVERY;            @ISA = 'NEXT';
  96. sub AUTOLOAD
  97. {
  98.     my ($self) = @_;
  99.     my $depth = 1;
  100.     until ((caller($depth))[3] !~ /^\(eval\)$/) { $depth++ }
  101.     my $caller = (caller($depth))[3];
  102.     my $wanted = $EVERY::AUTOLOAD || 'EVERY::AUTOLOAD';
  103.     undef $EVERY::AUTOLOAD;
  104.     my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
  105.  
  106.     local $NEXT::ALREADY_IN_EVERY{$self,$wanted_method} =
  107.           $NEXT::ALREADY_IN_EVERY{$self,$wanted_method};
  108.  
  109.     return if $NEXT::ALREADY_IN_EVERY{$self,$wanted_method}++;
  110.     
  111.     my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self,
  112.                                        $wanted_class;
  113.     @forebears = reverse @forebears if $wanted_class =~ /\bLAST\b/;
  114.     no strict 'refs';
  115.     my %seen;
  116.     my @every = map { my $sub = "${_}::$wanted_method";
  117.                   !*{$sub}{CODE} || $seen{$sub}++ ? () : $sub
  118.                 } @forebears
  119.                 unless $wanted_method eq 'AUTOLOAD';
  120.  
  121.     my $want = wantarray;
  122.     if (@every) {
  123.         if ($want) {
  124.             return map {($_, [$self->$_(@_[1..$#_])])} @every;
  125.         }
  126.         elsif (defined $want) {
  127.             return { map {($_, scalar($self->$_(@_[1..$#_])))}
  128.                      @every
  129.                    };
  130.         }
  131.         else {
  132.             $self->$_(@_[1..$#_]) for @every;
  133.             return;
  134.         }
  135.     }
  136.  
  137.     @every = map { my $sub = "${_}::AUTOLOAD";
  138.                !*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD"
  139.              } @forebears;
  140.     if ($want) {
  141.         return map { $$_ = ref($self)."::EVERY::".$wanted_method;
  142.                  ($_, [$self->$_(@_[1..$#_])]);
  143.                } @every;
  144.     }
  145.     elsif (defined $want) {
  146.         return { map { $$_ = ref($self)."::EVERY::".$wanted_method;
  147.                    ($_, scalar($self->$_(@_[1..$#_])))
  148.                  } @every
  149.                };
  150.     }
  151.     else {
  152.         for (@every) {
  153.             $$_ = ref($self)."::EVERY::".$wanted_method;
  154.             $self->$_(@_[1..$#_]);
  155.         }
  156.         return;
  157.     }
  158. }
  159.  
  160.  
  161. 1;
  162.  
  163. __END__
  164.  
  165. =head1 NAME
  166.  
  167. NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch
  168.  
  169.  
  170. =head1 SYNOPSIS
  171.  
  172.     use NEXT;
  173.  
  174.     package A;
  175.     sub A::method   { print "$_[0]: A method\n";   $_[0]->NEXT::method() }
  176.     sub A::DESTROY  { print "$_[0]: A dtor\n";     $_[0]->NEXT::DESTROY() }
  177.  
  178.     package B;
  179.     use base qw( A );
  180.     sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
  181.     sub B::DESTROY  { print "$_[0]: B dtor\n";     $_[0]->NEXT::DESTROY() }
  182.  
  183.     package C;
  184.     sub C::method   { print "$_[0]: C method\n";   $_[0]->NEXT::method() }
  185.     sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
  186.     sub C::DESTROY  { print "$_[0]: C dtor\n";     $_[0]->NEXT::DESTROY() }
  187.  
  188.     package D;
  189.     use base qw( B C );
  190.     sub D::method   { print "$_[0]: D method\n";   $_[0]->NEXT::method() }
  191.     sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
  192.     sub D::DESTROY  { print "$_[0]: D dtor\n";     $_[0]->NEXT::DESTROY() }
  193.  
  194.     package main;
  195.  
  196.     my $obj = bless {}, "D";
  197.  
  198.     $obj->method();        # Calls D::method, A::method, C::method
  199.     $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
  200.  
  201.     # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
  202.  
  203.  
  204.  
  205. =head1 DESCRIPTION
  206.  
  207. NEXT.pm adds a pseudoclass named C<NEXT> to any program
  208. that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to
  209. C<m> is redispatched as if the calling method had not originally been found.
  210.  
  211. In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first,
  212. left-to-right search of C<$self>'s class hierarchy that resulted in the
  213. original call to C<m>.
  214.  
  215. Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which
  216. begins a new dispatch that is restricted to searching the ancestors
  217. of the current class. C<$self-E<gt>NEXT::m()> can backtrack
  218. past the current class -- to look for a suitable method in other
  219. ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot.
  220.  
  221. A typical use would be in the destructors of a class hierarchy,
  222. as illustrated in the synopsis above. Each class in the hierarchy
  223. has a DESTROY method that performs some class-specific action
  224. and then redispatches the call up the hierarchy. As a result,
  225. when an object of class D is destroyed, the destructors of I<all>
  226. its parent classes are called (in depth-first, left-to-right order).
  227.  
  228. Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
  229. If such a method determined that it was not able to handle a
  230. particular call, it might choose to redispatch that call, in the
  231. hope that some other C<AUTOLOAD> (above it, or to its left) might
  232. do better.
  233.  
  234. By default, if a redispatch attempt fails to find another method
  235. elsewhere in the objects class hierarchy, it quietly gives up and does
  236. nothing (but see L<"Enforcing redispatch">). This gracious acquiescence
  237. is also unlike the (generally annoying) behaviour of C<SUPER>, which
  238. throws an exception if it cannot redispatch.
  239.  
  240. Note that it is a fatal error for any method (including C<AUTOLOAD>)
  241. to attempt to redispatch any method that does not have the
  242. same name. For example:
  243.  
  244.         sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
  245.  
  246.  
  247. =head2 Enforcing redispatch
  248.  
  249. It is possible to make C<NEXT> redispatch more demandingly (i.e. like
  250. C<SUPER> does), so that the redispatch throws an exception if it cannot
  251. find a "next" method to call.
  252.  
  253. To do this, simple invoke the redispatch as:
  254.  
  255.     $self->NEXT::ACTUAL::method();
  256.  
  257. rather than:
  258.  
  259.     $self->NEXT::method();
  260.  
  261. The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
  262. or it should throw an exception.
  263.  
  264. C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
  265. decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure 
  266. semantics:
  267.  
  268.     sub AUTOLOAD {
  269.         if ($AUTOLOAD =~ /foo|bar/) {
  270.             # handle here
  271.         }
  272.         else {  # try elsewhere
  273.             shift()->NEXT::ACTUAL::AUTOLOAD(@_);
  274.         }
  275.     }
  276.  
  277. By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
  278. method call, an exception will be thrown (as usually happens in the absence of
  279. a suitable C<AUTOLOAD>).
  280.  
  281.  
  282. =head2 Avoiding repetitions
  283.  
  284. If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
  285.  
  286.     #     A   B
  287.     #    / \ /
  288.     #   C   D
  289.     #    \ /
  290.     #     E
  291.  
  292.     use NEXT;
  293.  
  294.     package A;                 
  295.     sub foo { print "called A::foo\n"; shift->NEXT::foo() }
  296.  
  297.     package B;                 
  298.     sub foo { print "called B::foo\n"; shift->NEXT::foo() }
  299.  
  300.     package C; @ISA = qw( A );
  301.     sub foo { print "called C::foo\n"; shift->NEXT::foo() }
  302.  
  303.     package D; @ISA = qw(A B);
  304.     sub foo { print "called D::foo\n"; shift->NEXT::foo() }
  305.  
  306.     package E; @ISA = qw(C D);
  307.     sub foo { print "called E::foo\n"; shift->NEXT::foo() }
  308.  
  309.     E->foo();
  310.  
  311. then derived classes may (re-)inherit base-class methods through two or
  312. more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
  313. through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
  314. will invoke the multiply inherited method as many times as it is
  315. inherited. For example, the above code prints:
  316.  
  317.         called E::foo
  318.         called C::foo
  319.         called A::foo
  320.         called D::foo
  321.         called A::foo
  322.         called B::foo
  323.  
  324. (i.e. C<A::foo> is called twice).
  325.  
  326. In some cases this I<may> be the desired effect within a diamond hierarchy,
  327. but in others (e.g. for destructors) it may be more appropriate to 
  328. call each method only once during a sequence of redispatches.
  329.  
  330. To cover such cases, you can redispatch methods via:
  331.  
  332.         $self->NEXT::DISTINCT::method();
  333.  
  334. rather than:
  335.  
  336.         $self->NEXT::method();
  337.  
  338. This causes the redispatcher to only visit each distinct C<method> method
  339. once. That is, to skip any classes in the hierarchy that it has
  340. already visited during redispatch. So, for example, if the
  341. previous example were rewritten:
  342.  
  343.         package A;                 
  344.         sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() }
  345.  
  346.         package B;                 
  347.         sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() }
  348.  
  349.         package C; @ISA = qw( A );
  350.         sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() }
  351.  
  352.         package D; @ISA = qw(A B);
  353.         sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() }
  354.  
  355.         package E; @ISA = qw(C D);
  356.         sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() }
  357.  
  358.         E->foo();
  359.  
  360. then it would print:
  361.         
  362.         called E::foo
  363.         called C::foo
  364.         called A::foo
  365.         called D::foo
  366.         called B::foo
  367.  
  368. and omit the second call to C<A::foo> (since it would not be distinct
  369. from the first call to C<A::foo>).
  370.  
  371. Note that you can also use:
  372.  
  373.         $self->NEXT::DISTINCT::ACTUAL::method();
  374.  
  375. or:
  376.  
  377.         $self->NEXT::ACTUAL::DISTINCT::method();
  378.  
  379. to get both unique invocation I<and> exception-on-failure.
  380.  
  381. Note that, for historical compatibility, you can also use
  382. C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.
  383.  
  384.  
  385. =head2 Invoking all versions of a method with a single call
  386.  
  387. Yet another pseudo-class that NEXT.pm provides is C<EVERY>.
  388. Its behaviour is considerably simpler than that of the C<NEXT> family.
  389. A call to:
  390.  
  391.     $obj->EVERY::foo();
  392.  
  393. calls I<every> method named C<foo> that the object in C<$obj> has inherited.
  394. That is:
  395.  
  396.     use NEXT;
  397.  
  398.     package A; @ISA = qw(B D X);
  399.     sub foo { print "A::foo " }
  400.  
  401.     package B; @ISA = qw(D X);
  402.     sub foo { print "B::foo " }
  403.  
  404.     package X; @ISA = qw(D);
  405.     sub foo { print "X::foo " }
  406.  
  407.     package D;
  408.     sub foo { print "D::foo " }
  409.  
  410.     package main;
  411.  
  412.     my $obj = bless {}, 'A';
  413.     $obj->EVERY::foo();        # prints" A::foo B::foo X::foo D::foo
  414.  
  415. Prefixing a method call with C<EVERY::> causes every method in the
  416. object's hierarchy with that name to be invoked. As the above example
  417. illustrates, they are not called in Perl's usual "left-most-depth-first"
  418. order. Instead, they are called "breadth-first-dependency-wise".
  419.  
  420. That means that the inheritance tree of the object is traversed breadth-first
  421. and the resulting order of classes is used as the sequence in which methods
  422. are called. However, that sequence is modified by imposing a rule that the
  423. appropriate method of a derived class must be called before the same method of
  424. any ancestral class. That's why, in the above example, C<X::foo> is called
  425. before C<D::foo>, even though C<D> comes before C<X> in C<@B::ISA>.
  426.  
  427. In general, there's no need to worry about the order of calls. They will be
  428. left-to-right, breadth-first, most-derived-first. This works perfectly for
  429. most inherited methods (including destructors), but is inappropriate for
  430. some kinds of methods (such as constructors, cloners, debuggers, and
  431. initializers) where it's more appropriate that the least-derived methods be
  432. called first (as more-derived methods may rely on the behaviour of their
  433. "ancestors"). In that case, instead of using the C<EVERY> pseudo-class:
  434.  
  435.     $obj->EVERY::foo();        # prints" A::foo B::foo X::foo D::foo      
  436.  
  437. you can use the C<EVERY::LAST> pseudo-class:
  438.  
  439.     $obj->EVERY::LAST::foo();  # prints" D::foo X::foo B::foo A::foo      
  440.  
  441. which reverses the order of method call.
  442.  
  443. Whichever version is used, the actual methods are called in the same
  444. context (list, scalar, or void) as the original call via C<EVERY>, and return:
  445.  
  446. =over
  447.  
  448. =item *
  449.  
  450. A hash of array references in list context. Each entry of the hash has the
  451. fully qualified method name as its key and a reference to an array containing
  452. the method's list-context return values as its value.
  453.  
  454. =item *
  455.  
  456. A reference to a hash of scalar values in scalar context. Each entry of the hash has the
  457. fully qualified method name as its key and the method's scalar-context return values as its value.
  458.  
  459. =item *
  460.  
  461. Nothing in void context (obviously).
  462.  
  463. =back
  464.  
  465. =head2 Using C<EVERY> methods
  466.  
  467. The typical way to use an C<EVERY> call is to wrap it in another base
  468. method, that all classes inherit. For example, to ensure that every
  469. destructor an object inherits is actually called (as opposed to just the
  470. left-most-depth-first-est one):
  471.  
  472.         package Base;
  473.         sub DESTROY { $_[0]->EVERY::Destroy }
  474.  
  475.         package Derived1; 
  476.         use base 'Base';
  477.         sub Destroy {...}
  478.  
  479.         package Derived2; 
  480.         use base 'Base', 'Derived1';
  481.         sub Destroy {...}
  482.  
  483. et cetera. Every derived class than needs its own clean-up
  484. behaviour simply adds its own C<Destroy> method (I<not> a C<DESTROY> method),
  485. which the call to C<EVERY::LAST::Destroy> in the inherited destructor
  486. then correctly picks up.
  487.  
  488. Likewise, to create a class hierarchy in which every initializer inherited by
  489. a new object is invoked:
  490.  
  491.         package Base;
  492.         sub new {
  493.         my ($class, %args) = @_;
  494.         my $obj = bless {}, $class;
  495.         $obj->EVERY::LAST::Init(\%args);
  496.     }
  497.  
  498.         package Derived1; 
  499.         use base 'Base';
  500.         sub Init {
  501.         my ($argsref) = @_;
  502.         ...
  503.     }
  504.  
  505.         package Derived2; 
  506.         use base 'Base', 'Derived1';
  507.         sub Init {
  508.         my ($argsref) = @_;
  509.         ...
  510.     }
  511.  
  512. et cetera. Every derived class than needs some additional initialization
  513. behaviour simply adds its own C<Init> method (I<not> a C<new> method),
  514. which the call to C<EVERY::LAST::Init> in the inherited constructor
  515. then correctly picks up.
  516.  
  517.  
  518. =head1 AUTHOR
  519.  
  520. Damian Conway (damian@conway.org)
  521.  
  522. =head1 BUGS AND IRRITATIONS
  523.  
  524. Because it's a module, not an integral part of the interpreter, NEXT.pm
  525. has to guess where the surrounding call was found in the method
  526. look-up sequence. In the presence of diamond inheritance patterns
  527. it occasionally guesses wrong.
  528.  
  529. It's also too slow (despite caching).
  530.  
  531. Comment, suggestions, and patches welcome.
  532.  
  533. =head1 COPYRIGHT
  534.  
  535.  Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
  536.  This module is free software. It may be used, redistributed
  537.     and/or modified under the same terms as Perl itself.
  538.